home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist02.zoo / sources / xlisp.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-05-04  |  4.4 KB  |  205 lines
  1. /* xlisp.c - a small implementation of lisp with object-oriented programming */
  2. /*        Copyright (c) 1987, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use        */
  5.  
  6. #include "xlisp.h"
  7. #include <stdlib.h>
  8.  
  9. /* define the banner line string */
  10. #ifdef STRUCTS
  11. #define BANNER    "XLISP version 2.1, Copyright (c) 1988, by David Betz\n\
  12. As modified by Thomas Almy, compiled for Atari ST 30:04:91"
  13. #else
  14. #define BANNER    "XLISP version 2.0, Copyright (c) 1988, by David Betz\n\
  15. As modified by Thomas Almy"
  16. #endif
  17.  
  18. /* global variables */
  19. jmp_buf top_level;
  20.  
  21. /* external variables */
  22. extern LVAL s_stdin,s_evalhook,s_applyhook;
  23. extern LVAL s_1plus,s_2plus,s_3plus,s_1star,s_2star,s_3star,s_minus;
  24. extern int xltrcindent;
  25. extern int xldebug;
  26. extern LVAL true;
  27. extern char buf[];
  28. extern FILE *tfp;
  29.  
  30. /* external routines */
  31. extern FILE *osaopen();
  32.  
  33. #ifdef MSC6
  34. /* no optimization which interferes with setjmp */
  35. #pragma optimize("elg",off)
  36. #endif
  37.  
  38. /* usage - print command line usage, then quit */
  39. VOID usage() {
  40.     fprintf(stderr,"Valid Arguments:\n\t-?\tThis help\n\
  41. \t-tfname\tOpen transcript (dribble) file fname\n\
  42. \t-v\tLoad verbosely\n\
  43. \t-w\tDon't restore from xlisp.wks\n\
  44. \tfname\tLoad file fname\n");
  45.     exit(1);
  46. }
  47.  
  48. /* main - the main routine */
  49. VOID main(argc,argv)
  50.   int argc; char *argv[];
  51. {
  52.     char *transcript;
  53.     CONTEXT cntxt;
  54.     int verbose,nores,i;
  55.     LVAL expr;
  56.  
  57. #ifdef PROFILES
  58.     prof_start(argv[0]);
  59. #endif
  60.  
  61.     /* setup default argument values */
  62.     transcript = NULL;
  63.     verbose = FALSE;
  64.     nores = FALSE;
  65.  
  66.     /* parse the argument list switches */
  67. #ifndef LSC
  68.     for (i = 1; i < argc; ++i)
  69.         if (argv[i][0] == '-')
  70.             switch(tolower(argv[i][1])) {
  71.             case '?':    /* TAA MOD: added help */
  72.                 usage();
  73.             case 't':
  74.                 transcript = &argv[i][2];
  75.                 break;
  76.             case 'v':
  77.                 verbose = TRUE;
  78.                 break;
  79.             case 'w':
  80.                 nores = TRUE;
  81.                 break;
  82.             default: /* Added to print bad switch message */
  83.                 fprintf(stderr,"Bad switch: %s\n",argv[i]);
  84.                 usage();
  85.             }
  86. #endif
  87.  
  88.     /* initialize and print the banner line */
  89.     osinit(BANNER);
  90.  
  91.     /* setup initialization error handler */
  92.     xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,(LVAL)1);
  93.     if (setjmp(cntxt.c_jmpbuf))
  94.         xlfatal("fatal initialization error");
  95.     if (setjmp(top_level))
  96.         xlfatal("RESTORE not allowed during initialization");
  97.  
  98.     /* initialize xlisp */
  99.     i = xlinit(nores);
  100.     xlend(&cntxt);
  101.  
  102.     /* reset the error handler */
  103.     xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,true);
  104.  
  105.     /* open the transcript file */
  106.     if (transcript && (tfp = osaopen(transcript,"w")) == NULL) {
  107.         /* TAA Mod -- quote name so "-t foo" will indicate no file name */
  108.         sprintf(buf,"error: can't open transcript file: \"%s\"",transcript);
  109.         stdputstr(buf);
  110.     }
  111.  
  112.     /* load "init.lsp" */
  113.     if (i && (setjmp(cntxt.c_jmpbuf) == 0))
  114.         xlload("init.lsp",TRUE,FALSE);
  115.  
  116.     /* load any files mentioned on the command line */
  117.     if (setjmp(cntxt.c_jmpbuf) == 0)
  118.         for (i = 1; i < argc; i++)
  119.             if (argv[i][0] != '-' && !xlload(argv[i],TRUE,verbose))
  120.                 xlerror("can't load file",cvstring(argv[i]));
  121.  
  122.     /* target for restore */
  123.     if (setjmp(top_level))
  124.         xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,true);
  125.  
  126.     /* protect some pointers */
  127.     xlsave1(expr);
  128.  
  129.     /* main command processing loop */
  130.     for (;;) {
  131.  
  132.         /* setup the error return */
  133.         if (setjmp(cntxt.c_jmpbuf)) {
  134.             setvalue(s_evalhook,NIL);
  135.             setvalue(s_applyhook,NIL);
  136.             xltrcindent = 0;
  137.             xldebug = 0;
  138.             xlflush();
  139.         }
  140.  
  141.         /* print a prompt */
  142.         stdputstr("> ");
  143.  
  144.         /* read an expression */
  145.         if (!xlread(getvalue(s_stdin),&expr))
  146.             break;
  147.  
  148.         /* save the input expression */
  149.         xlrdsave(expr);
  150.  
  151.         /* evaluate the expression */
  152.         expr = xleval(expr);
  153.  
  154.         /* save the result */
  155.         xlevsave(expr);
  156.  
  157.         /* print it */
  158.         stdprint(expr);
  159.     }
  160.     xlend(&cntxt);
  161.  
  162.     /* clean up */
  163.     wrapup();
  164. }
  165.  
  166. #ifdef MSC6
  167. #pragma optimize("",on)
  168. #endif
  169.  
  170. /* xlrdsave - save the last expression returned by the reader */
  171. VOID xlrdsave(expr)
  172.   LVAL expr;
  173. {
  174.     setvalue(s_3plus,getvalue(s_2plus));
  175.     setvalue(s_2plus,getvalue(s_1plus));
  176.     setvalue(s_1plus,getvalue(s_minus));
  177.     setvalue(s_minus,expr);
  178. }
  179.  
  180. /* xlevsave - save the last expression returned by the evaluator */
  181. VOID xlevsave(expr)
  182.   LVAL expr;
  183. {
  184.     setvalue(s_3star,getvalue(s_2star));
  185.     setvalue(s_2star,getvalue(s_1star));
  186.     setvalue(s_1star,expr);
  187. }
  188.  
  189. /* xlfatal - print a fatal error message and exit */
  190. VOID xlfatal(msg)
  191.   char *msg;
  192. {
  193.     oserror(msg);
  194.     wrapup();
  195. }
  196.  
  197. /* wrapup - clean up and exit to the operating system */
  198. VOID wrapup()
  199. {
  200.     if (tfp)
  201.         osclose(tfp);
  202.     osfinish();
  203.     exit(0);
  204. }
  205.